home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
SK210F
/
TESTDRVR.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-05-09
|
18KB
|
561 lines
unit TestDrvr;
{
Test suite driver
for the
SkyHawk Developer's ToolKit.
Copyright 1991 Madison & Associates
All Rights Reserved
This program source file and the associated executable
file may be used and distributed only in accordance
with the provisions described on the title page of
the accompanying documentation file
SKYHAWK.DOC
}
interface
uses
Dos,
TestBetw, TestCmpx, TestColr, TestCrc, TestDate,
TestFin, TestList, TestUtil,
ShClrDef, ShCmplx, ShCrcChk, ShDatPk, ShFinanc,
ShList, ShUtilPk,
TpString, TpCrt, TpCmd, TpDos, TpEdit,
TpMemChk, TpWindow, TpMenu,
ShErrMsg;
{$IFNDEF DPMI}
type
InitExecFunc = function(LastToSave : pointer;
SwapFileName : string) : boolean;
ExecSwapFunc = function(Path, CmdLine : string) : word;
var
InitExecF : InitExecFunc;
ExecSwapF : ExecSwapFunc;
{$ENDIF}
procedure DoTests;
implementation
var
Xsave,
Ysave : byte;
WinBuf : pointer;
procedure DoTests;
const
MaxItems = 12;
HelpLine : array[1..MaxItems] of string[40] =
('Tests of BETWEEN routines in ShUtilPk.' ,
'Tests of Color Selection unit.' ,
'Tests of Command Line Parsing unit.' ,
'Tests of Complex Arithmetic unit.' ,
'Tests of File CRC unit.' ,
'Tests of Date Manipulation unit.' ,
'Tests of Error Message unit.' ,
'Tests of List Processing unit.' ,
'Tests of Long String Processing unit.' ,
'Tests of remainder of ShUtilPk.' ,
'Sequences through the entire test suite.',
'Tests of Financial unit.'
);
var
O : text;
SMA,
SXA : LongInt;
procedure InitMenu(var M : Menu);
const
Color1 : MenuColorArray = (
YellowOnBlack, {Frame Color}
YellowOnBlack, {Menu Header Color}
LtCyanOnBlue, {Body Color}
WhiteOnBrown, {Selected Item Color}
WhiteOnBlue, {Pick Character Color}
YellowOnBlack, {Help Row Color}
CyanOnBlue, {Disabled Item Color}
DkGrayOnLtGray {Shadow Color}
);
Frame1 : FrameArray = '╔╚╗╝═║';
var
C1 : char;
T1 : byte;
begin
C1 := 'A';
T1 := 1;
{Customize this call for special exit characters and custom item
displays}
M := NewMenu([], nil);
SubMenu(24,5,4,Vertical,Frame1,Color1,' SKYHAWK TEST MENU ');
MenuItem(C1+': Perform all tests' ,T1, 1,11,
Center(HelpLine[11], 72));
inc(C1); inc(T1);
MenuItem(C1+': Test BetwS, BetwU' ,T1, 1, 1,
Center(HelpLine[ 1], 72));
inc(C1); inc(T1);
MenuItem(C1+': Test ShClrDef' ,T1, 1, 2,
Center(HelpLine[ 2], 72));
inc(C1); inc(T1);
MenuItem(C1+': Test ShCmdLin' ,T1, 1, 3,
Center(HelpLine[ 3], 72));
inc(C1); inc(T1);
MenuItem(C1+': Test ShCmplx' ,T1, 1, 4,
Center(HelpLine[ 4], 72));
inc(C1); inc(T1);
MenuItem(C1+': Test ShCrcChk' ,T1, 1, 5,
Center(HelpLine[ 5], 72));
inc(C1); inc(T1);
MenuItem(C1+': Test ShDatPk' ,T1, 1, 6,
Center(HelpLine[ 6], 72));
inc(C1); inc(T1);
MenuItem(C1+': Test ShErrMsg' ,T1, 1, 7,
Center(HelpLine[ 7], 72));
inc(C1); inc(T1);
MenuItem(C1+': Test ShFinanc' ,T1, 1,12,
Center(HelpLine[12], 72));
inc(C1); inc(T1);
MenuItem(C1+': Test ShList' ,T1, 1, 8,
Center(HelpLine[ 8], 72));
inc(C1); inc(T1);
MenuItem(C1+': Test ShLngStr' ,T1, 1, 9,
Center(HelpLine[ 9], 72));
inc(C1); inc(T1);
MenuItem(C1+': Test ShUtilPk' ,T1, 1,10,
Center(HelpLine[10], 72));
inc(C1); inc(T1);
MenuItem( 'X: Exit to DOS' ,T1, 1,99,
Center('Exit from the test program.', 72));
PopSublevel;
ResetMenu(M);
end; {InitMenu}
procedure TestHeader(B : byte);
begin
SMA := MemAvail;
SXA := MaxAvail;
GoToXYabs(1, ScreenHeight);
WriteLn(O,Center(CharStr('*',60), 72));
WriteLn(O,Center(CharStr('*',60), 72));
WriteLn(O,Center(CenterCh(' '+HelpLine[B]+' ','*',60), 72));
WriteLn(O,Center(CharStr('*',60), 72));
WriteLn(O,Center(CharStr('*',60), 72));
WriteLn(O);
Flush(O);
end; {TestHeader}
procedure TestTrailer(B : byte);
var
MA,
XA : LongInt;
S1 : string;
begin {TestTrailer}
MA := MemAvail;
XA := MaxAvail;
WriteLn(O,^M^J,Center(CharStr('*',60), 72));
S1 := ' End of '+HelpLine[B]+' ';
WriteLn(O, Center(CenterCh(S1,'*',60), 72));
S1 := ' '+Long2Str(SMA)+' ** MemAvail ** '+Long2Str(MA)+' ';
WriteLn(O, Center(CenterCh(S1,'*',60),72));
S1 := ' '+Long2Str(SXA)+' ** MaxAvail ** '+Long2Str(XA)+' ';
WriteLn(O, Center(CenterCh(S1,'*',60),72));
WriteLn(O, Center(CharStr('*',60), 72));
if not HandleIsConsole(1) then
WriteLn(O,^L)
else begin
WriteLn(O);
WriteLn(O);
end;
Flush(O);
end; {TestTrailer}
procedure AnyKey;
begin
if HandleIsConsole(1) then begin
Write('Any key to continue... ');
if ReadKey = #0 then ;
GoToXY(1, WhereY);
DelLine;
end;
end;
var
XSwpOK : boolean;
XSwpErr : word;
M : Menu;
Ch : Char;
Key : MenuKey;
procedure BetwFunctionsTest;
begin {BetwFunctionsTest}
TestHeader(Key);
BetwTest;
TestTrailer(Key);
end; {BetwFunctionsTest}
procedure ColorSelectionTest;
begin {ColorSelectionTest}
TestHeader(Key);
if HandleIsConsole(1) then
ColrTest
else
WriteLn(O, 'Test not available under redirection.');
TestTrailer(Key);
end; {ColorSelectionTest}
procedure CommandLineTest;
const
A : array[1..2] of string[ 9] =
('a:''14.26''',
'a: 14.26 ' );
B : array[1..1] of string[ 5] =
(';b=17');
T : array[1..3] of string[13] =
('/30:''thirty'' ',
'/30:''thi"rty''',
'/30:"thi''rty"' );
C : array[1..4] of string[ 8] =
('-c:''40a ' ,
'-c:''40a''',
'-c: 40a"' ,
'-c: 40a ' );
D : array[1..2] of string[32] =
(';d=This is a packable arg.' ,
';d=''This is a non-packable arg.''');
begin {CommandLineTest}
TestHeader(Key);
{$IFDEF DPMI}
XSwpErr := ExecDos('TESTCMDL ' +
A[1] +
B[1] +
T[1] +
C[1] +
D[1], true, nil);
if XSwpErr <> 0 then
WriteLn('ExecDOS Error = ', XSwpErr);
XSwpErr := ExecDos('TESTCMDL ' +
A[2] +
B[1] +
T[1] +
C[2] +
D[2], true, nil);
if XSwpErr <> 0 then
WriteLn('ExecDOS Error = ', XSwpErr);
XSwpErr := ExecDos('TESTCMDL ' +
A[1] +
B[1] +
T[1] +
C[4] +
D[1], true, nil);
if XSwpErr <> 0 then
WriteLn('ExecDOS Error = ', XSwpErr);
XSwpErr := ExecDos('TESTCMDL ' +
A[2] +
B[1] +
T[2] +
C[3] +
D[2], true, nil);
if XSwpErr <> 0 then
WriteLn('ExecDOS Error = ', XSwpErr);
XSwpErr := ExecDos('TESTCMDL ' +
A[1] +
B[1] +
T[2] +
C[4] +
D[1], true, nil);
if XSwpErr <> 0 then
WriteLn('ExecDOS Error = ', XSwpErr);
XSwpErr := ExecDos('TESTCMDL ' +
A[1] +
B[1] +
T[3] +
C[4] +
D[2], true, nil);
if XSwpErr <> 0 then
WriteLn('ExecDOS Error = ', XSwpErr);
{$ELSE}
SwapVectors;
XSwpErr := ExecSwapF('TESTCMDL.EXE',
A[1] +
B[1] +
T[1] +
C[1] +
D[1] );
if XSwpErr <> 0 then
WriteLn('Exec Swap Error = ', XSwpErr);
XSwpErr := ExecSwapF('TESTCMDL.EXE',
A[2] +
B[1] +
T[1] +
C[2] +
D[2] );
if XSwpErr <> 0 then
WriteLn('Exec Swap Error = ', XSwpErr);
XSwpErr := ExecSwapF('TESTCMDL.EXE',
A[1] +
B[1] +
T[1] +
C[4] +
D[1] );
if XSwpErr <> 0 then
WriteLn('Exec Swap Error = ', XSwpErr);
XSwpErr := ExecSwapF('TESTCMDL.EXE',
A[2] +
B[1] +
T[2] +
C[3] +
D[2] );
if XSwpErr <> 0 then
WriteLn('Exec Swap Error = ', XSwpErr);
XSwpErr := ExecSwapF('TESTCMDL.EXE',
A[1] +
B[1] +
T[2] +
C[4] +
D[1] );
if XSwpErr <> 0 then
WriteLn('Exec Swap Error = ', XSwpErr);
XSwpErr := ExecSwapF('TESTCMDL.EXE',
A[1] +
B[1] +
T[3] +
C[4] +
D[2] );
if XSwpErr <> 0 then
WriteLn('Exec Swap Error = ', XSwpErr);
SwapVectors;
{$ENDIF}
TestTrailer(Key);
end; {CommandLineTest}
procedure ComplexArithmeticTest;
begin {ComplexArithmeticTest}
TestHeader(Key);
CmpxTest;
TestTrailer(Key);
end; {ComplexArithmeticTest}
procedure CrcCalculationTest;
begin {CrcCalculationTest}
TestHeader(Key);
CrcTest;
TestTrailer(Key);
end; {CrcCalculationTest}
procedure DateManipulationTest;
begin {DateManipulationTest}
TestHeader(Key);
DateTest;
TestTrailer(Key);
end; {DateManipulationTest}
procedure ErrorMessagesTest;
begin {ErrorMessagesTest}
TestHeader(Key);
if HandleIsConsole(1) then begin
{$IFDEF DPMI}
repeat
WriteLn;
XSwpErr := ExecDos('TESTERR', true, nil);
if XSwpErr <> 0 then WriteLn('ExecDOS Error = ', XSwpErr);
until not YesOrNo('Again? ... ', WhereY, WhereX, $07, 'Y');
{$ELSE}
SwapVectors;
repeat
WriteLn;
XSwpErr := ExecSwapF('TESTERR.EXE', '');
if XSwpErr <> 0 then WriteLn('Exec Swap Error = ', XSwpErr);
until not YesOrNo('Again? ... ', WhereY, WhereX, $07, 'Y');
SwapVectors;
{$ENDIF}
end
else
WriteLn(O, 'Test not available under redirection.');
TestTrailer(Key);
end; {ErrorMessagesTest}
procedure FinancialCalculationsTest;
begin {FinancialCalculationsTest}
TestHeader(Key);
TestFinance;
TestTrailer(Key);
end; {FinancialCalculationsTest}
procedure GenericListProcessorTest;
begin {GenericListProcessorTest}
TestHeader(Key);
ListTest;
TestTrailer(Key);
end; {GenericListProcessorTest}
procedure LongStringManipulationTest;
begin {LongStringManipulationTest}
TestHeader(Key);
{$IFDEF DPMI}
XSwpErr := ExecDos('TESTLSTR', true, nil);
if XSwpErr <> 0 then WriteLn('ExecDOS Error = ', XSwpErr);
{$ELSE}
SwapVectors;
XSwpErr := ExecSwapF('TESTLSTR.EXE', '');
if XSwpErr <> 0 then WriteLn('Exec Swap Error = ', XSwpErr);
SwapVectors;
{$ENDIF}
AnyKey;
TestTrailer(Key);
end; {LongStringManipulationTest}
procedure LowLevelUtilitiesTest;
begin {LowLevelUtilitiesTest}
TestHeader(Key);
UtilTest;
TestTrailer(Key);
end; {LowLevelUtilitiesTest}
begin {Main Program}
Xsave := WhereX;
Ysave := WhereY;
if not SaveWindow(1, 1, ScreenWidth, ScreenHeight, true, WinBuf) then ;
ClrScr;
if OpenStdDev(O, 1) then ;
Key := -1;
{$IFDEF DPMI}
XSwpOK := true;
{$ELSE}
XSwpOK := InitExecF(HeapPtr, 'SHTEST.$$$');
{$ENDIF}
repeat
InitMenu(M);
if not XSwpOK then begin
DisableMenuItem(M, 3); {Command Line}
DisableMenuItem(M, 7); {Error Messages}
DisableMenuItem(M, 9); {LongString Manipulation}
end;
if HandleIsConsole(1) then begin
if Key = -1 then
Key := 1;
end {if HandleIsConsole}
else {if not HandleIsConsole} begin
if Key = -1 then
Key := 11;
DisableMenuItem(M, 2); {Color Selection}
DisableMenuItem(M, 7); {Error Messages}
end;
SelectMenuItem(M, Key);
Key := MenuChoice(M, Ch);
EraseMenu(M, false);
DisposeMenu(M);
case Key of
1 : begin
BetwFunctionsTest;
end;
2 : begin
ColorSelectionTest;
end;
3 : begin
CommandLineTest;
end;
4 : begin
ComplexArithmeticTest;
end;
5 : begin
CrcCalculationTest;
end;
6 : begin
DateManipulationTest;
end;
7 : begin
ErrorMessagesTest;
end;
8 : begin
GenericListProcessorTest;
end;
9 : begin
LongStringManipulationTest;
end;
10 : begin
LowLevelUtilitiesTest;
end;
11 : begin
Key := 1;
BetwFunctionsTest;
Key := 2;
ColorSelectionTest;
Key := 3;
CommandLineTest;
Key := 4;
ComplexArithmeticTest;
Key := 5;
CrcCalculationTest;
Key := 6;
DateManipulationTest;
Key := 7;
ErrorMessagesTest;
Key := 12;
FinancialCalculationsTest;
Key := 8;
GenericListProcessorTest;
Key := 9;
LongStringManipulationTest;
Key := 10;
LowLevelUtilitiesTest;
Key := 99;
end;
12 : begin
FinancialCalculationsTest;
end;
99 : begin
RestoreWindow(1, 1, ScreenWidth, ScreenHeight, true, WinBuf);
GoToXYabs(Xsave, Ysave);
Halt;
end;
end; {case}
until false;
end; {Main Program}
end.